/* Definitions for the cons type.

   This file is part of khipu.

   khipu is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.  */

#include "khipu.hpp"

KP_DECLS_BEGIN

[[noreturn]] static inline void
raise_circular (interpreter *interp)
{
  interp->raise ("arg-error", "argument must not be circular");
}

[[noreturn]] static inline void
raise_dotted (interpreter *interp)
{
  interp->raise ("arg-error", "argument must not be dotted");
}

int32_t len_L (interpreter *, object lst, object& dotc)
{
  int ret = 0;
  cons::unsafe_iter it (lst);
  for (; it.valid (); ++it, ++ret);

  if (it.circular ())
    return (-1);

  dotc = it.node ();
  return (ret);
}

int32_t len_L (interpreter *interp, object lst)
{
  object tail;
  int ret = len_L (interp, lst, tail);

  if (tail != NIL && ret > 0)
    raise_dotted (interp);

  return (ret);
}

object cons::make (interpreter *interp, object car, object cdr)
{
  cons *ret = as_cons (alloc_cons (interp));
  ret->car = car, ret->cdr = cdr;
  kp_return (interp->alval);
}

object nputcar (interpreter *interp, object lst, object obj)
{
  xcar(lst) = obj;
  gc_wbarrier (interp, lst, obj);
  kp_return (lst);
}

object nputcdr (interpreter *interp, object lst, object obj)
{
  xcdr(lst) = obj;
  gc_wbarrier (interp, lst, obj);
  kp_return (lst);
}

static object&
cons_ref (interpreter *interp, int idx, object& obj)
{
  cons::unsafe_iter it (obj);
  if (idx < 0)
    {
      object tail;
      int rl = len_L (interp, obj, tail);
      if (rl < 0)
        raise_circular (interp);
      else if ((idx += rl) < 0)
        interp->raise_oob (0, -1);
    }

  for (; idx > 0 && it.valid (); --idx, ++it);
  if (!it.valid ())
    interp->raise_oob (0, -1);

  return (obj = it.node ());
}

object nthcdr (interpreter *interp, object idx, object obj)
{
  if (!fixint_p (idx))
    interp->raise ("type-error", "first argument must be an integer");
  else if (!xcons_p (obj))
    interp->raise ("type-error", "second argument must be a cons");

  kp_return (cons_ref (interp, as_int (idx), obj));
}

object get_L (interpreter *interp, object obj,
  object idx, object dfl)
{
  int iv;

  if (kp_unlikely (dfl != UNBOUND))
    interp->raise_nargs (2, 2, 3);
  else if (!as<int> (idx, iv))
    interp->raise ("type-error", "index is not an integer");

  kp_return (xcar (cons_ref (interp, iv, obj)));
}

object nput_L (interpreter *interp, object obj,
  object idx, object val)
{
  int iv;

  if (kp_unlikely (!as<int> (idx, iv)))
    interp->raise ("type-error", "index is not an integer");

  nputcar (interp, cons_ref (interp, iv, obj), val);
  kp_return (val);
}

object last_L (interpreter *interp, object lst)
{
  cons::unsafe_iter it (lst);
  for (; cons_p (xcdr (it.node ())); ++it)
    if (it.circular ())
      raise_circular (interp);

  kp_return (it.node ());
}

static void
adjust_idx (interpreter *interp, object obj, int& ix, int *p)
{
  object tail;
  int rl = len_L (interp, obj, tail);

  if (rl < 0)
    raise_circular (interp);

  ix += rl;
  if (p)
    *p += rl;
}

object subseq_L (interpreter *interp,
  object obj, object ix1, object ix2)
{

  if (ix2 == UNBOUND)
    {
      valref tmp (interp, nthcdr (interp, ix1, obj));
      return (copy (interp, *tmp, false));
    }

  int i1, i2;

  if (kp_unlikely (!as<int> (ix1, i1) || !as<int> (ix2, i2)))
    interp->raise ("type-error", "indices must be integers");
  else if (i1 < 0)
    adjust_idx (interp, obj, i1, i2 < 0 ? &i2 : nullptr);
  else if (i2 < 0)
    adjust_idx (interp, obj, i2, nullptr);

  if ((i1 | i2) < 0 || i1 > i2)
    interp->raise ("index-error", "indices out of bounds");

  int rlen = i2 - i1;
  object ret = alloc_cons (interp, rlen);
  cons::unsafe_iter it (obj);

  for (int i = 0; i < i1 && it.valid (); ++i, ++it);
  for (; i1 < i2 && it.valid (); ++i1, ++it)
    {
      xcar(ret) = *it;
      ret = xcdr (ret);
    }

  xcdr(ret) = NIL;
  kp_return (interp->alval);
}

static inline void
revcopy (interpreter *interp, object& acc, cons::iterator& it)
{
  for (; it.valid (); ++it)
    acc = cons::make (interp, copy (interp, *it, true), acc);
}

static inline void
revcopy_shallow (interpreter *interp, object& acc, cons::iterator& it)
{
  for (; it.valid (); ++it)
    acc = cons::make (interp, *it, acc);
}

object copy_L (interpreter *interp, object obj, bool deep)
{
  if (obj == NIL)
    kp_return (obj);

  cons::iterator it (interp, obj);
  fast_valref acc (interp, NIL);
  revcopy (interp, *acc, it);

  interp->aux = nreverse_L (interp, *acc);

  if (it.circular ())
    nputcdr (interp, *acc, it.prev_node ());
  else if (!xcons_p (it.node ()))
    nputcdr (interp, *acc, it.node ());

  kp_return (interp->aux);
}

static const uint32_t CONS_HASH_SEED = 1936617315;

uint32_t hash_L (interpreter *interp, object obj)
{
  uint32_t ret = CONS_HASH_SEED;
  if (obj == NIL)
    return (ret);

  cons::iterator it (interp, obj);

  while (true)
    {
      ret = mix_hash (ret, xhash (interp, *it));

      if (!(++it).valid ())
        {
          object pt = it.node ();
          if (pt != UNBOUND && pt != NIL)
            { // Dotted list - Hash the tail and mix it again.
              ret = mix_hash (ret, xhash (interp, pt));
              ret = mix_hash (ret, CONS_HASH_SEED);
            }

          break;
        }
    }

  return (ret);
}

object iter_L (interpreter *interp, object obj, object token, bool adv)
{
  if (token == UNBOUND)
    kp_return (obj);
  else if (!cons_p (token))
    interp->raise ("arg-error", "invalid token");
  else if (!adv)
    kp_return (xcar (token));

  if (!xcons_p (interp->retval = xcdr (token)))
    raise_dotted (interp);

  return (interp->retval);
}

object nreverse_L (interpreter *interp, object obj)
{
  object prev = NIL, tmp = obj;
  object *pp = &prev;

  while (tmp != NIL)
    {
      object qx = xcdr (tmp);
      if (!xcons_p (qx))
        raise_dotted (interp);

      /* Write barriers shouldn't be necessary here, since we are rearranging
       * an existing list; that is the responsibility of other mutators. */

      xcdr(tmp) = *pp;
      *pp = tmp, tmp = qx;
    }

  kp_return (prev);
}

object reverse_L (interpreter *interp, object obj)
{
  cons::iterator it (interp, obj);
  fast_valref ret (interp, NIL);

  for (; it.valid (); ++it)
    *ret = cons::make (interp, *it, *ret);

  if (!xcons_p (it.node ()))
    interp->raise ("arg-error", "argument is not a proper list");

  kp_return (*ret);
}

object concat_L (interpreter *interp, object *argv, int argc)
{
  if (argc == 1)
    kp_return (*argv);

  valref acc (interp, NIL);
  for (int i = 0; i < argc - 1; ++i)
    {
      if (xcons_p (argv[i]))
        {
          cons::iterator it (interp, argv[i]);
          revcopy_shallow (interp, *acc, it);

          if (it.node () == NIL)
            continue;
        }

      interp->raise ("arg-error", "arguments must be proper lists");
    }

  if (*acc == NIL)
    kp_return (argv[argc - 1]);

  nreverse_L (interp, *acc);
  xcdr(*acc) = argv[argc - 1];
  return (interp->retval);
}

object add_LL (interpreter *interp, object l1, object l2)
{
  object args[] = { l1, l2 };
  return (concat_L (interp, args, 2));
}

object nsort_L (interpreter *interp, object obj, comparator& cmp)
{
  cons::iterator it (interp, obj), tmp (interp, NIL);
  fast_valref nm (interp);

  for (; it.valid (); ++it)
    {
      tmp.reset (it);
      *nm = it.node ();

      while ((++tmp).valid ())
        if (cmp (*tmp, xcar (*nm)))
          *nm = tmp.node ();

      if (tmp.circular ())
        raise_circular (interp);
      else if (it.node () != *nm)
        swap (xcar (it.node ()), xcar (*nm));
    }

  kp_return (obj);
}

object nconcat (interpreter *interp, object *argv, int argc)
{
  if (!argc)
    kp_return (NIL);
  else if (argc == 1)
    kp_return (*argv);

  int i;
  for (i = 0; i < argc; ++i)
    if (!xcons_p (argv[i]))
      {
        if (i == argc - 1)
          kp_return (argv[i]);

        interp->raise ("type-error", "arguments must be lists");
      }
    else if (argv[i] != NIL)
      break;

  if (i == argc)
    kp_return (argv[i - 1]);

  valref_head h (interp);
  fast_valref ret (interp, argv[i++]),
              tail (interp, last_L (interp, *ret));

  for (; i < argc - 1; ++i)
    {
      if (argv[i] == NIL)
        continue;
      else if (!xcons_p (argv[i]))
        interp->raise ("type-error", "arguments must be lists");

      nputcdr (interp, *tail, argv[i]);
      *tail = last_L (interp, argv[i]);
    }

  nputcdr (interp, *tail, argv[argc - 1]);
  kp_return (*ret);
}

object nrevconc (interpreter *interp, object lst, object tail)
{
  if (!xcons_p (lst))
    interp->raise ("type-error", "first argument must be a list");

  valref_head h (interp);
  fast_valref sl (interp, lst), rv (interp, nreverse_L (interp, *sl));
  nputcdr (interp, *sl, tail);
  kp_return (*rv);
}

bool eq_LL (interpreter *interp, object l1, object l2)
{
  cons::iterator l_it (interp, l1), r_it (interp, l2);

  for (; l_it.valid () && r_it.valid (); ++l_it, ++r_it)
    if (!equal (interp, *l_it, *r_it))
      return (false);

  if (l_it.node () == NIL)
    return (r_it.node () == NIL);

  return (!l_it.circular () && !r_it.circular () &&
    equal (interp, l_it.node (), r_it.node ()));
}

int cmp_LL (interpreter *interp, object l1, object l2)
{
  cons::iterator l_it (interp, l1), r_it (interp, l2);

  for (; l_it.valid () && r_it.valid (); ++l_it, ++r_it)
    {
      int rv = xcmp (interp, *l_it, *r_it);
      if (rv != 0)
        return (rv);
    }

  if (l_it.circular () || r_it.circular ())
    return (-1);
  else if (r_it.node () == NIL)
    return (l_it.node () != r_it.node ());
  else if (l_it.node () == NIL)
    return (-(r_it.node () != l_it.node ()));

  return (xcmp (interp, l_it.node (), r_it.node ()));
}

object nzap_L (interpreter *interp, object obj, object key,
  uint32_t flags, object fn, object *argv, int argc)
{
  int iv;

  if (kp_unlikely (!as<int> (key, iv)))
    interp->raise ("type-error", "index is not an integer");
  else if (kp_unlikely (flags & NZAP_DFL))
    interp->raise ("arg-error", "default argument not supported");

  interp->growstk (argc + 2);
  interp->push (fn);
  interp->push (fixint (0));   // Placeholder.

  int stack_idx = interp->stklen () - 1;
  for (int i = 0; i < argc; ++i)
    interp->push (argv[i]);

  valref_head h (interp);
  fast_valref prev (interp), ref (interp, obj);
  cons_ref (interp, iv, *ref);
  atomic_t *ref_ptr = (atomic_t *)&xcar(*ref);

  if (flags & NZAP_NOMT)
    {
      interp->stack[stack_idx] = *prev = *ref_ptr;
      nputcar (interp, *ref, call_n (interp, argc + 1));
      interp->retval = xcar (interp->retval);
    }
  else
    while (true)
      {
        *prev = xcar (*ref);
        interp->stack[stack_idx] = *prev;

        call_n (interp, argc + 1);
        if (atomic_cas_bool (ref_ptr,
                             (atomic_t)*prev, (atomic_t)interp->retval))
          {
            gc_wbarrier (interp, *ref, interp->retval);
            break;
          }

        atomic_spin_nop ();
      }

  if (flags & NZAP_PREV)
    interp->retval = *prev;

  return (interp->retval);
}

object find_L (interpreter *interp, object obj,
  object key, object start, object end, object test)
{
  int istart = start == UNBOUND ? as_int (start) : 0;
  int iend = end == UNBOUND ? FIXINT_MAX : as_int (end);

  if (istart < 0)
    adjust_idx (interp, obj, istart, iend < 0 ? &iend : nullptr);
  else if (iend < 0)
    adjust_idx (interp, obj, iend, nullptr);

  if (istart > iend)
    kp_return (NIL);
  else if ((istart | iend) < 0)
    interp->raise ("index-error", "indices out of bounds");

  cons::unsafe_iter it (obj);
  for (int i = 0; i < istart && it.valid (); ++it) ;

  if (test == UNBOUND)
    {
      valref tmp (interp, fixint (0));
      for (; istart < iend && it.valid (); ++it, ++istart)
        if (equal (interp, key, *it))
          kp_return (it.node ());
    }
  else
    {
      interp->growstk (3);
      for (; istart < iend && it.valid (); ++it, ++istart)
        {
          *interp->stkend++ = test;
          *interp->stkend++ = key;
          *interp->stkend++ = *it;
          if (call_n (interp, 2) != NIL)
            kp_return (it.node ());
        }
    }

  if (it.circular ())
    raise_circular (interp);

  kp_return (NIL);
}

int write_L (interpreter *interp, stream *strm, object obj, io_info& info)
{
  if (obj == NIL)
    return (strm->write (interp, "nil", 3));
  else if (xcar (obj) == symbol::quote &&
      xcons_p (xcdr (obj)) && xcddr (obj) == NIL)
    {
      valref prev (interp, xcadr (obj));
      strm->putb (interp, '\'');
      return (xwrite (interp, strm, *prev) + 1);
    }

  int ret = strm->putb (interp, '(');
  cons::iterator it (interp, obj);

  while (true)
    {
      ret += xwrite (interp, strm, *it, info);

      if ((++it).valid ())
        {
          ret += strm->putb (interp, ' ');
          continue;
        }
      else if (it.circular ())
        ret += strm->write (interp, " ...", 4);
      else if (!xcons_p (it.node ()))
        {
          ret += strm->write (interp, " . ", 3);
          ret += xwrite (interp, strm, it.node (), info);
        }

      break;
    }

  return (ret + strm->putb (interp, ')'));
}

int64_t pack_L (interpreter *interp, stream *strm,
  object obj, pack_info& info)
{
  pack_info::eviction_guard eg { info, true };
  cons::iterator it (interp, obj);
  int64_t ret = xpack (interp, strm, *it, info);

  for (++it; it.valid (); ++it)
    { /* Here we inline part of the packing routine to avoid
       * pathological cases of very deep recursion, which can
       * lead to a stack overflow. */
      object off = info.get (interp, it.node ());
      if (off != UNBOUND)
        {
          int ioff = as_int (off);
          info.touch (interp, ioff);
          ret += strm->putb (interp, PACK_REF_INT32) +
                 strm->write (interp, &ioff);
          break;
        }

      info.add_mapping (interp, it.node (), strm->tell (interp));
      ret += strm->putb (interp, typecode::CONS) +
             xpack (interp, strm, *it, info);
    }

  if (it.node () == NIL)
    ret += strm->putb (interp, PACK_NIL);
  else if (!it.circular ())
    ret += xpack (interp, strm, it.node (), info);

  return (ret);
}

object unpack_L (interpreter *interp, stream *strm, pack_info& info, bool save)
{
  valref_head h (interp);
  fast_valref pos (interp, *info.offset), out (interp, NIL);
  while (true)
    {
      *out = cons::make (interp, xunpack (interp, strm, info), *out);
      if (save)
        info.add_mapping (interp, *pos, *out);

      *pos = strm->tell (interp);
      int tp = strm->peekb (interp);
      if (tp < 0)
        kp_return (info.error ("invalid typecode"));

      save = (tp & 0x80) != 0;
      tp &= ~0x80;

      if (tp != typecode::CONS)
        {
          if (tp != PACK_NIL)
            *out = nrevconc (interp, *out,
              *pos = xunpack (interp, strm, info));
          else
            {
              *out = nreverse_L (interp, *out);
              strm->getb (interp);
            }

          kp_return (*out);
        }

      strm->getb (interp);
    }
}

// External definitions.
static const cons C_NIL = 
{
#ifdef KP_ARCH_WIDE
  ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL,
  ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL
#else
  (object)&C_NIL | 2,
  (object)&C_NIL | 2
#endif
};

const object NIL =
#ifdef KP_ARCH_WIDE
  ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL;
#else
  (object)&C_NIL | 2;
#endif

static int
do_init_cons (interpreter *)
{
  ensure_mask_impl ((void *)&C_NIL);
  return (init_op::result_ok);
}

init_op init_cons (do_init_cons, "cons");

KP_DECLS_END

